module Compiler where

import Syntax
import Maybe

{- 
 - Visita (e trasformazione) dell'albero di parsing
 -}

compile :: HsExp -> HsExp
compile e = hsRequire "Fusion" `hsConcat` 
            hsMap (transformHighOrder e . 
                   transform) e
 
transform :: HsExp -> HsExp

transform (HsUnaryOp HsPreIncrement x) = transformPreOp hsSetAdd x
transform (HsUnaryOp HsPreDecrement x) = transformPreOp hsSetSub x
transform (HsUnaryOp HsPostIncrement x) = transformPostOp hsPreIncrement x
transform (HsUnaryOp HsPostDecrement x) = transformPostOp hsPreDecrement x

transform (HsUnaryOp op x) = hsUnaryOp op x

transform (HsBinaryOp HsOpHashMember x y) = hsArrayIndex x y

transform (HsBinaryOp op1 x z@(HsBinaryOp op2 y _))
  | isRelationalOp op1 && 
    isRelationalOp op2 &&
    (not $ isHsRelationalOp x) = hsBinaryOp op1 x y `hsAnd` z

transform (HsListComprehension item fors select) = 
  hsBrace $ hsLineSequence $ [varset, fors', var]
  where
    var = hsVar "_"
    varset = var `hsSet` hsArray []
    item' = var `hsShiftLeft` item
    fors' = aux $ reverse fors
    
    aux :: [(HsExp, HsExp)] -> HsExp
    aux [] = case select of
      Nothing -> item
      Just cond -> hsIfOnly cond item'
    aux ((x, range):fors) = hsFor x range (aux fors)

-- TODO: generalizzare il cambio variabile
transform (HsArrayIndex array seq@(HsUnaryOp HsOpRangeIncludeLeft left)) 
  | hsIsSimple array = hsArrayIndex array $ left `hsRangeExclude` hsCallMethod array "length" [] Nothing
  | otherwise        = transform $ hsBrace $ hsLineSequence [tmpvar `hsSet` array, hsArrayIndex tmpvar seq]
  where
    tmpvar = hsVar "_"

transform (HsBlock block body) = transform' block body
  where
    -- Abstract method
    transform' (HsMethod HsOptAbstract kind name args) body =
      hsMultiLineSequence [
        hsMethod kind name args body, 
        hsCallName "set_abstract_method" [hsSymbol name] Nothing
      ]
    
    -- Static method
    transform' (HsMethod HsOptStatic kind name args) body =
      transform $ hsMethod kind ("self." ++ name) args body
    
    -- Main without parameters
    transform' (HsMethod HsOptNone HsMethodProcedure "main" Nothing) main =
      hsIfOnly (hsConst "__FILE__" `hsEqual` hsGlobal "0") main
    
    -- Main with parameters
    transform' (HsMethod HsOptNone HsMethodProcedure "main" (Just args)) main =
      transform $ hsProcedure "main" Nothing body
      where
        body = hsConcat settings main
    
        settings = hsMultiLineSequence $ fst $ foldr aggr ([], length args - 1) args
          where
            aggr arg (res, i) = (setArg i arg : res, i - 1)
    
        setArg index (HsMethodArg name defval _) = hsVar name `hsSet` value
          where
            argv = hsArrayIndex (hsConst "ARGV") (hsInt index)
            value = case defval of
              Nothing     -> argv
              Just defval -> argv `hsOr` defval

    -- Generic function
    transform' (HsMethod HsOptNone (HsMethodFunction rettype) name args) body = 
      case hsFind hsVisitTopLevel hsIsReturnValue body of
        Nothing -> error $ "function '" ++ name ++ "' must return a value"
        Just _  -> transform $ hsDef name args body'
      where
        body' = case rettype of
          Nothing -> body
          Just t  -> 
            hsMap checkReturn body
              where
                checkReturn (HsReturn (Just e)) = hsReturnValue $ checkType t e
                checkReturn e = e
    
    -- Generic procedure
    transform' (HsMethod HsOptNone HsMethodProcedure name args) body = 
      case hsFind hsIsExecuted hsIsReturnValue body of
        Nothing -> transform $ hsDef name args body
        Just _  -> error $ "procedure '" ++ name ++ "' cannot return a value"
    
    -- Generic function/procedure with parameters
    transform' (HsMethod HsOptNone HsMethodDef name (Just args)) body = 
      hsDef name (Just args') (check `hsConcat` body')
      where
        args' = map removeArgType args
        removeArgType (HsMethodArg name defval _) = hsMethodArg name defval Nothing
        
        check = foldr aggr hsEmpty args
          where
            aggr (HsMethodArg name _ (Just t)) e = checkType t (hsVar name) `hsConcat` e
            aggr _ e = e
        
        body' = hsMap aux body
          where
            aux (HsCall m@(HsVar name) callArgs block) 
              | isJust $ hsGetMethodArg name args = hsCallMethod m "call" callArgs block
            aux e = e
          
    -- Auto-constructor
    transform' (HsClass name args@(Just args') super interfaces) body = 
      transform $ hsClass name Nothing super interfaces (accessors `hsConcat` body')
      where
        initialize = "initialize"
        body' | hsExistsMethod initialize body = hsMap updateInit body
              | otherwise                      = createInit `hsConcat` body
    
        createInit = transform $ hsProcedure initialize args settings
    
        updateInit (HsBlock (HsMethod HsOptNone kind "initialize" Nothing) body) = 
          transform $ hsProcedure initialize args $ settings `hsConcat` body
        updateInit e = e
    
        settings = hsMultiLineSequence $ map setAttr args'
          where
            setAttr (HsMethodArg name _ _) = hsAttr name `hsSet` hsVar name
        
        accessors = hsCallName "attr_accessor" (map (hsSymbol . hsArgName) args') Nothing
    
    -- Generic class
    transform' (HsClass name Nothing super interfaces) body = 
      hsClass name Nothing super [] body'
      where
        check_abstract = isJust super || not (null interfaces)
        interfaces' = hsMultiLineSequence $ map includeInterface interfaces
          where
            includeInterface name = hsCallName "include" [hsVar name] Nothing
        body' = if check_abstract then
                  interfaces' `hsConcat` 
                  body `hsConcat` 
                  hsCallName "check_abstracts_methods" [] Nothing
                else
                  body
    
    -- Generic interface
    transform' (HsInterface name) body = hsModule name body
    
    -- Struct
    transform' (HsStruct name args) _ = 
      transform $ hsDef name (Just args) $ hsReturnValue $ HsHash $ map getKey args
      where
        getKey (HsMethodArg argName _ _) = HsHashKey (hsSymbol argName) (hsVar argName)
    
    transform' block body = HsBlock block body

transform (HsCall v@(HsVar "new") (cl:args) block) = 
  hsCall (cl `hsMember` v) args block

transform (HsCall method args block) = hsCall method' args block'
  where
    method' = case method of
      HsVar "print" -> hsVar "puts"
      HsVar "puts"  -> hsVar "print"
      otherwise -> method
    
    block' = case block of
      Nothing -> Nothing
      Just (HsCallBlock args body) -> Just $ hsCallBlock args body

transform (HsRequire names) = hsMultiLineSequence $ map hsRequire names

transform (HsWith item body) = body'
  where
    body' = hsMap f body
    f (HsVar "y") = hsInt 0
    f e = e

transform (HsTypedExp typename es) = hsMultiLineSequence $ map (checkType typename) es

transform e = e

transformPreOp op x = transform $ x `op` hsInt 1
transformPostOp op x = hsLineSequence $ transforms $ [varset, y, var]
  where
    var = hsVar "_"
    varset = var `hsSet` x
    y = op x

{- 
 - Trasformazione del passaggio di funzione come argomento.
 - Se f è una funzione (o procedura), una chiamata del tipo "g f x" viene trasformata in
 - "g (method :f) x".
 - All'interno del corpo di g è invece opportuno sostituire le chiamate del tipo "f x y"
 - con "f.call x y".
 -}
transformHighOrder :: HsExp -> HsExp -> HsExp
transformHighOrder allExp (HsCall method args block) = 
  hsCall method (map aux args) block
  where
    aux (HsVar name) | isJust $ hsGetMethod name allExp = 
      hsCallName "method" [hsSymbol name] Nothing
    aux arg = arg
transformHighOrder _ e = e

{-
 - Trasformazioni generiche
 -}

-- e => e.check_type(t)
checkType t e = hsCallMethod e "check_type" [hsVar t] Nothing

transforms es = map transform es

transformMaybe Nothing  = Nothing
transformMaybe (Just e) = Just $ transform e

transformIfCond (cond, body) = (transform cond, transform body)

transformMethodArg (HsMethodArg name defval t) = hsMethodArg name (transformMaybe defval) t
transformMethodArgs Nothing     = Nothing
transformMethodArgs (Just args) = Just $ map transformMethodArg args